C
C THIS FORTRAN-77 PROGRAM WAS DEVELOPED TO ALLOW VAX/VMS COMPUTERS TO
C READ THE "ALMOST-ANSI-STANDARD" ADA SOURCE CODE REPOSITORY TAPES.
C
C
C IT WAS DEVELOPED BY CHARLES A. FINNELL AND HARRY E. JEGERS OF
C
C                     ADA SYSTEMS BRANCH
C                 TELEDYNE BROWN ENGINEERING
C                   788 SHREWSBURY AVENUE
C                  TINTON FALLS, NJ 07724
C                      (201) 741-5008
C
C
C WE CALLED IT "READ-TAPE-USING-QIOW.FOR" ON OUR VAX/VMS 4.2 SYSTEM.
C
C THIS PROGRAM DOES NOT REFLECT OUR KNOWLEDGE OF GOOD FORTRAN STYLE.
C IT WAS HACKED TOGETHER FROM SCRATCH OVER A TWO WEEK PERIOD (JAN86)
C DURING WHICH WE GRADUALLY DISCOVERED WHAT WORKED AND WHAT DIDN'T.
C DESPITE ITS APPEARANCE, THIS PROGRAM SUCCESSFULLY READ BOTH OF THE
C "ALMOST-ANSI-STANDARD  TAPES SHIPPED AS COPIES OF THE MASTER TAPE
C PRODUCED BY "WRITEL" IN DECEMBER 1985.
C
C USAGE NOTES:
C FIRST YOU NEED TO COMPILE AND LINK THIS PROGRAM BY ISSUING THE
C FOLLOWING DCL COMMANDS:
C
C $ FORTRAN READ-TAPE-USING-QIOW
C $ LINK    READ-TAPE-USING-QIOW
C
C IF THIS SUCCEEDS, GET YOUR SYSTEM MANAGER TO "$ RUN AUTHORIZE"
C AND GIVE YOU THE "VOLPRO" PRIVILEGE, WHICH YOU NEED TO READ
C THE TAPES WE GOT, AND PHYSICALLY MOUNT THE FIRST TAPE IN YOUR
C TAPE DRIVE.
C
C NEXT ISSUE THE FOLLOWING DCL COMMANDS, REPLACING "MSAO:" BY
C THE NAME OF YOUR TAPE DRIVE:
C
C $ SET PROCESS/PRIV=VOLPRO
C $ MOUNT/NOWRITE/OVERRIDE=(OWNER,ACCESS)/FOREIGN MSAO: ADA TAPE
C
C IF THIS SUCCEEDS, RUN THIS PROGRAM AS FOLLOWS:
C
C $ RUN READ-TAPE-USING-QIOW
C
C THIS PROGRAM WILL TAKE SEVERAL HOURS TO RUN (4 HRS. ON OUR VAX 11/730)
C AND WILL COPY ALMOST 45,000 512-BYTE BLOCKS OF DATA INTO THE DEFAULT
C DIRECTORY.  NOTE THAT THE BIG FILE "SP2MASTER.DCT" EXISTS PARTLY
C ON THE END OF THE FIRST TAPE AND PARTLY ON THE BEGINNING OF THE
C SECOND TAPE.  YOU WILL EVENTUALLY NEED TO USE THE FOLLOWING DCL
C COMMAND TO COMBINE THESE TWO PIECES:
C
C $ COPY/LOG SP2MASTER.DCT;l,SP2MASTER.DCT;2 SP2MASTER.DCT;3
C
C NOTE THAT THE HIERARCHICAL STRUCTURE OF THE SIMTEL20 DIRECTORIES
C WAS LOST WHEN THE "ALMOST-ANSI-STANDARD" TAPES WERE MADE.  YOU WILL
C HAVE TO USE "$ CREATE" TO MAKE SOME SUBDIRECTORIES AND "$ RENAME"
C TO MOVE THE FILES UNDER THE APPROPRIATE SUBDIRECTORIES IF YOU WANT
C TO ORGANIZE THE FILES AS SPECIFIED ON THE DOCUMENTATION THAT
C WAS SUPPLIED WITH THE TAPE.  USE THE DISK FILE CREATION TIMES AS
C A GUIDE TO MAKE SURE YOU GET EACH FILE INTO THE PROPER SUBDIRECTORY.
C
C PLEASE FEEL FREE TO USE THIS PROGRAM FOR ANY PURPOSE WHATSOEVER.
C
       CHARACTER*1  REC FORM
       CHARACTER*5  BLCK LEN, REC LEN
       CHARACTER*17 FILENM
       CHARACTER*80 LABEL
       CHARACTER*2000 BUFFER

       PARAMETER EOF = '870'X !END OF FILE MARK
       PARAMETER IO$READLBLK = '21'X ! READ LOGICAL BLOCK CODE FOR QIOW
       PARAMETER IO$REWIND = '24'X ! REWIND CODE FOR QIOW

       PARAMETER NOLOGNAM = '908'X ! RETURN CODE FOR NO ASSIGNED LOGILCAL NAME
       PARAMETER NOPRIV = '24' X ! RETURN CODE FOR IMPROPER SET UP OR PRIV.

       PARAMETER LABSIZE = 80
       PARAMETER BUFSIZE = 2000

       INTEGER*2 CHANO, IOSB(4), BUFLEN
       INTEGER*4 SYS$ASSIGN, SYS$QIOW, RETCODE
       INTEGER*2 VLRLEN,VLRNDX

       INTEGER COUNT, WRTCOUNT

       DATA WRTCOUNT/0/

C ASSIGN THE TAPE DRIVE SO THE TAPE CAN BE READ :
       RETCODE = SYS$ASSIGN('TAPE', CHANO,,)
       IF (RETCODE.NE.1) GOTO 2000

C REWIND THE TAPE AND PREPARE TO READ IT :
       RETCODE = SYS$QIOW(, %VAL(CHANO), %VAL(IO$REWIND), IOSB,,,,,,,,)
       IF (RETCODE.NE.1) GOTO 2000

C READ FIRST LABEL (VOLUME LABEL) :
20     RETCODE = SYS$QIOW(, %VAL(CHANO), %VAL(IO$READLBLK), IOSB,,,
     1                    %REF(LABEL(1:1)), %VAL(LABSIZE),,,,)
       IF (RETCODE.NE.1) GO TO 21
       IF (LABEL(1:7).EQ.'VOL1ADA') THEN
         WRITE(6,23) LABEL(1:7)
23       FORMAT(1X, 'The volume label on this tape is : ', A8)
         GO TO 30
      ENDIF

C HANDLE ANY ERROR IN READING THE FIRST LABEL ON THE TAPE
21     WRITE(6,24) LABEL(1:7)
24     FORMAT(1X, '*** VOLUME LABEL ERROR : The label is - ', A8)
       GO TO 3000

C READ THE SECOND LABEL (FIRST HEADER CONTAINING THE FILE NAME OF THE
C SOURCE CODE TO BE READ.
30     RETCODE = SYS$QIOW(, %VAL(CHANO), %VAL(IO$READLBLK), IOSB,,,
     1                    %REF(LABEL(1:1)), %VAL(LABSIZE),,,,)
       IF (RETCODE.NE.1) GO TO 31
       IF (IOSB(1).EQ.EOF) GO TO 32
       IF ((LABEL(1:4).EQ.'EOF1').OR.(LABEL(1:4).EQ.'EOF2').OR.
     1     (LABEL(1:4).EQ.'EOV1').OR.(LABEL(1:4).EQ.'EOV2')) THEN
         COUNT = 0
         WRITE(6,200) LABEL(1:4)
200      FORMAT(1X,'--- Found an ',A,' record ---')
         GO TO 30
       ENDIF
       IF (LABEL(1:4).EQ.'HDR1') THEN
         FILENM = LABEL(5:21)
         DO I=1,17                             ! added
           IF(FILENM(I:I) .EQ. '-' )THEN       ! added
             FILENM(I:I) = '_'                 ! added
           END IF                              ! added
         END DO                                ! added
         WRITE(6,33) FILENM
33       FORMAT(1X,'>>>> The name of this file is : ', A17)
         GO TO 40
        ELSE
         GO TO 30
        ENDIF

C HANDLE ANY ERROR IN READING THE NEXT LABEL ON THE TAPE
31     WRITE(6,34) LABEL(1:21)
34     FORMAT(1X, '*** ERROR IN THE FILE NAME : The label is - ', A21)
       GO TO 3000

C KEEP TRACK OF EOF (TAPE) MARKS ON THE TAPE, IF TWO IN A ROW ARE
C REACHED THE STOP READING THE TAPE.  IF THERE ARE MORE THAN TWO MARKS
C IN A ROW THERE IS AN ERROR.
32     IF (COUNT.EQ.1) THEN
         WRITE(6,35)
35       FORMAT(1X,'--- Reached two tape marks in a row (EOT) ---')
         GOTO 3050
       ELSE
         IF (COUNT.GE.2) THEN
           WRITE(6,36)
36         FORMAT(1X, '*** ERROR IN TAPE; TOO MANY EOF MARKS ***')
         ELSE
           WRITE(6,37)
37         FORMAT(1X, '--- Reached a tape mark (EOF) ---')
           COUNT = COUNT + 1
           GO TO 30
         ENDIF
       ENDIF
       GO TO 3000

C READ THE SECOND HEADER CONTAINING SOME LESS IMPORTANT INFORMATION
40     RETCODE = SYS$QIOW(, %VAL(CHANO), %VAL(IO$READLBLK), IOSB,,,
     1                    %REF(LABEL(1:1)), %VAL(LABSIZE),,,,)
       IF (RETCODE.NE.1) GO TO 41
       IF (LABEL(1:4).EQ.'HDR2') THEN
         REC FORM = LABEL(5:5)
         BLCK LEN = LABEL(6:10)
         REC LEN  = LABEL(11:15)
         WRITE(6,43) REC FORM, BLCK LEN, REC LEN 
43       FORMAT(1X,'REC FORM = ',A1,' BLCK LEN = ',A5,' REC LEN = ',A5)
         COUNT = 0
         GO TO 49
       ELSE
         GO TO 40
       ENDIF

C HANDLE ANY ERROR WHEN READING THE THIRD LABEL ON THE TAPE
41     WRITE(6,44) LABEL(1:15)
44     FORMAT(1X, '*** ERROR IN THE FILE CHARACTERISTICS : ',
     1'The label is - ', A15)
       GO TO 3000

C CREATE THE FILE TO CONTAIN THE DATA FROM THE TAPE, MAKING SURE
C THAT THE DISK FILE WILL HAVE THE SAME FORMAT AS NORMAL DISK
C FILES CREATED BY THE "EDT" EDITOR:
49     OPEN(UNIT=30, CARRIAGECONTROL='LIST', RECORDTYPE='VARIABLE',
     1 FORM='UNFORMATTED', FILE=FILENM, STATUS='NEW', ERR=53)

C EXTRACT THE SOURCE LISTINGS FROM THE TAPE :
50     RETCODE = SYS$QIOW(, %VAL(CHANO), %VAL(IO$READLBLK), IOSB,,,
     1                    %REF(BUFFER(1:1)), %VAL(BUFSIZE),,,,)
       IF (RETCODE.NE.1) GO TO 52
       IF (IOSB(1).EQ.EOF) GO TO 51
       BUFLEN = IOSB(2)
       IF (WRTCOUNT.LT.20) THEN
         WRITE(6,61) BUFLEN
61       FORMAT(1X,'BUFLEN = ',I5,' BUFFER(1:80) = ')
         WRITE(6,54) BUFFER(1:80)
54       FORMAT(1X,A)
         WRTCOUNT = WRTCOUNT + 1
       ENDIF

C      >------> DEBLOCK THE VARYING-LENGTH RECORDS:
       VLRNDX = 1
100    CONTINUE
       IF (VLRNDX+3.GT.BUFLEN) GOTO 50
       DECODE(4, 105, BUFFER(VLRNDX:VLRNDX+3), ERR=110) VLRLEN
105    FORMAT(I4)
       IF ((1.LE.VLRNDX+4) .AND. (VLRNDX+4.LE.VLRNDX+VLRLEN-1) .AND.
     1   (VLRNDX+VLRLEN-1.LE.BUFLEN)) THEN
C        WRITE OUT A LOGICAL RECORD IF IT HAS AT LEAST ONE DATA BYTE:
         WRITE(UNIT=30, ERR=55) BUFFER(VLRNDX+4:VLRNDX+VLRLEN-1)
       ELSE
C        WRITE(6,60) VLRNDX, VLRLEN,.BUFLEN
C60      FORMAT(1X,'*> VLRNDX = ',I5,' VLRLEN = ',I5,' BUFLEN = ',I5)
C        WRITE A NULL RECORD (BLANK LINE) WHERE NECESSARY:
         WRITE(UNIT=30, ERR=55)
      ENDIF
62     CONTINUE
       VLRNDX = VLRNDX + VLRLEN
       GOTO 100

C      HANDLE ANY ERRORS FROM DECODE (WE NEVER GOT ANY):
110    WRITE(6,120) VLRNDX, VLRLEN, BUFLEN
120    FORMAT(1X,'*D*> VLRNDX = ',I5,' VLRLEN = ',I5,' BUFLEN = ',I5)
       GOTO 50

C KEEP TRACK OF EOF (TAPE) MARKS
51     COUNT = COUNT + 1
       WRITE(6,56) COUNT
56     FORMAT(1X, 'Reached EOF (Tape) mark; COUNT = ', I4)
       IF (COUNT.EQ.1) THEN
         GO TO 50
       ELSE
         IF (COUNT.EQ.2) CLOSE(UNIT=30)
         IF (COUNT.EQ.2) GO TO 30
       ENDIF
       GO TO 3000

C HANDLE ANY ERROR IN READING FROM THE TAPE
52     WRITE(6,57)
57     FORMAT(1X, '*** ERROR IN READING THE TAPE ***')
       GO TO 3000

C HANDLE ANY ERROR IN OPENING THE NEW FILE
53     WRITE(6,58) FILENM
58     FORMAT(1X, '*** ERROR IN OPENING OUTPUT FILE : ', A16,' ***')
       GO TO 3000

C HANDLE ANY ERROR IN WRITING THE SOURCE TO A NEW FILE
55     WRITE(6,59) FILENM
59     FORMAT(1X, '*** ERROR IN WRITING TO FILE : ', A16, ' ***')
       GOTO 62

2000   IF (RETCODE.NE.1) THEN
         IF (RETCODE.EQ.NOLOGNAM) THEN
          WRITE(6,2010)
2010       FORMAT(1X, '*** ASSIGN LOGICAL NAME "TAPE" ***')
         ENDIF
         IF (RETCODE.EQ.NOPRIV) THEN
           WRITE(6,2020)
2020       FORMAT(1X, '*** TAPE MUST BE MOUNTED FOREIGN ***')
         ENDIF
       ENDIF
3000   CONTINUE
       WRITE(6,3005) RETCODE
3005   FORMAT(1X,'RETCODE = ', I5)
       WRITE(6,3010)
3010   FORMAT(1X, '*** TAPE READING TERMINATED ***')
       CALL LIB$STOP(%VAL(RETCODE))
3050   CONTINUE
       END
